home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 12 / Cream of the Crop 12 (Part II) / Cream of the Crop 12 (Part II).iso / OS2 / XL21HOS2.ZIP / TURTLE.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1995-12-27  |  3.8 KB  |  125 lines
  1. ;; TURTLE.L for PC-LISP.EXE V2.10
  2. ;; Modified for XLISP 2.1d by Tom Almy
  3. ;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  4. ;;      A set of turtle graphics primitives to demonstrate PC-LISP's BIOS 
  5. ;; graphics routines. These routines are pretty self explanitory. The first
  6. ;; 5 defun's define the primitives, next are a set of routines to draw things
  7. ;; like squares, triangles etc. Try the function (GraphicsDemo). It will
  8. ;; draw Squirals, Trianglerals, etc. Note that the BIOS line drawing is really
  9. ;; slow. This is because the BIOS 'set dot/pixel' routine is used for every
  10. ;; point in a line. Using the BIOS has the advantage however of portability,
  11. ;; these routines work on virtually every MS-DOS machine. The global variable
  12. ;; *GMODE* controls the graphics resolution that will be used. It is set by 
  13. ;; default to 6 I set it to 8 or 9 for my 2000 but these routines will not
  14. ;; support the lower resolution modes. 
  15. ;;
  16. ;;                      Peter Ashwood-Smith
  17. ;;                      April 2nd, 1986 
  18. ;;
  19.  
  20.  
  21. ;; Several bugs  fixed by Tom Almy
  22. ;; The playing field is 200x200, after scaling.
  23. ;; Lfactor = ypixels/200
  24. ;; Scale = xpixels/ypixels
  25. ;; CenterX=CenterY= ypixels/2
  26.  
  27.  
  28.  
  29. (defvar *GMODE* 18)                                     ; default setting
  30.  
  31.  
  32. #+:times (defun pause (time) 
  33.        (let ((fintime (+ (* time internal-time-units-per-second)
  34.                  (get-internal-run-time))))
  35.         (loop (when (> (get-internal-run-time) fintime)
  36.                 (return-from pause)))))
  37. #-:times (defun pause () (dotimes (x (* time 1000))))
  38.  
  39.  
  40. (defun TurtleGraphicsUp (&aux dims)           
  41.        (setq
  42.     dims
  43.     (case *GMODE*
  44.           ((6 16 18)            ; 640x200 B&W mode
  45.                         ; 640x350 Graphics
  46.                             ; 640x480 VGA Graphics
  47.            (mode *GMODE*))
  48.           (t (error "unsupported *GMODE* - ~s" *GMODE*))))
  49.        (setq  Lfactor (/ (1+ (fourth dims)) 200)
  50.           Scale   (/ (1+ (third dims)) (1+ (fourth dims)))
  51.           CenterX (/ (1+ (fourth dims)) 2)
  52.           CenterY CenterX
  53.           Lastx CenterX
  54.           Lasty CenterY
  55.           Heading 0)
  56.        (cls)
  57.        (color 15)
  58. )   
  59.  
  60. (defun TurtleGraphicsDown() 
  61.     (mode 3) (cls))
  62. (defun TurtleCenter()       
  63.     (setq Lastx CenterX Lasty CenterY Heading 1.570796372))
  64. (defun TurtleRight(n)       (setq Heading (- Heading (* n 0.01745329))))
  65. (defun TurtleLeft(n)        (setq Heading (+ Heading (* n 0.01745329))))
  66. (defun TurtleGoto(x y)      (setq Lastx (* x Lfactor) Lasty (* y Lfactor) )) 
  67.  
  68. (defun TurtleForward(n) 
  69.       (setq n (* n Lfactor) 
  70.               Newx (+ Lastx (* (cos Heading) n))
  71.         Newy (+ Lasty (* (sin Heading) n)))
  72.       (move (truncate (* Lastx Scale))
  73.             (truncate Lasty)
  74.         (truncate (* Newx Scale))
  75.         (truncate Newy))
  76.       (setq Lastx Newx Lasty Newy)
  77. )
  78.  
  79. ;
  80. ; end of Turtle Graphics primitives, start of Graphics demonstration code
  81. ; you can cut this out if you like and leave the Turtle primitives intact.
  82. ;
  83.  
  84. (defun Line_T(n)        
  85.     (TurtleForward n) (TurtleRight 180)
  86.     (TurtleForward (/ n 4)) 
  87. )
  88.     
  89. (defun Square(n)
  90.     (TurtleForward n)  (TurtleRight 90)     
  91.     (TurtleForward n)  (TurtleRight 90)     
  92.     (TurtleForward n)  (TurtleRight 90)     
  93.     (TurtleForward n)                       
  94. )
  95.  
  96. (defun Triangle(n)
  97.     (TurtleForward n)  (TurtleRight 120)
  98.     (TurtleForward n)  (TurtleRight 120)
  99.     (TurtleForward n)
  100. )
  101.  
  102. (defun Make(ObjectFunc Size star skew) 
  103.       (dotimes (dummy star)
  104.        (apply ObjectFunc (list Size)) 
  105.        (TurtleRight skew)
  106.        )
  107. )
  108.  
  109. (defun GraphicsDemo()
  110.        (TurtleGraphicsUp) 
  111.        (Make #'Square 40 18 5) (Make #'Square 60 18 5)
  112.        (pause 1.0)
  113.        (TurtleGraphicsUp) 
  114.        (Make #'Triangle 40 18 5) (Make #'Triangle 60 18 5)
  115.        (pause 1.0)
  116.        (TurtleGraphicsUp) 
  117.        (Make #'Line_T 80 50 10)
  118.        (pause 1.0)
  119.        (TurtleGraphicsDown)
  120. )
  121.  
  122. (print "Try (GraphicsDemo)")
  123.  
  124. (setq *features* (cons :turtle *features*))
  125.